Visual Basic Source Code/Visual Basic Source Code.iso/vbsource/caldr/caldr1.frm

Visual Basic Form | 1995-05-08 | 13.3 KB | 452 lines

VERSION 2.00
Begin Form Form1
   BackColor       =   &H00C0C0C0&
   Caption         =   "Calendar Demo"
   ClientHeight    =   4020
   ClientLeft      =   1080
   ClientTop       =   1485
   ClientWidth     =   7365
   Height          =   4425
   Left            =   1020
   LinkTopic       =   "Form1"
   ScaleHeight     =   268
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   491
   Top             =   1140
   Width           =   7485
   Begin CommandButton Command1
      Caption         =   "Calendar"
      Height          =   525
      Left            =   1140
      TabIndex        =   7
      Top             =   165
      Width           =   1665
   End
   Begin PictureBox Calendar
      AutoRedraw      =   -1  'True
      BackColor       =   &H00C0C0C0&
      ForeColor       =   &H00800000&
      Height          =   1800
      Left            =   4590
      ScaleHeight     =   118
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   147
      TabIndex        =   0
      Top             =   255
      Visible         =   0   'False
      Width           =   2235
      Begin SSCommand btnMonth
         BevelWidth      =   0
         Caption         =   "Command3D1"
         Font3D          =   0  'None
         Height          =   285
         Index           =   0
         Left            =   615
         TabIndex        =   5
         Top             =   570
         Width           =   315
      End
      Begin SSCommand btnYear
         BevelWidth      =   0
         Caption         =   "Command3D1"
         Font3D          =   0  'None
         Height          =   300
         Index           =   0
         Left            =   1005
         TabIndex        =   2
         Top             =   405
         Width           =   315
      End
      Begin PictureBox Picture1
         AutoRedraw      =   -1  'True
         BackColor       =   &H00C0C0C0&
         Height          =   375
         Left            =   120
         ScaleHeight     =   23
         ScaleMode       =   3  'Pixel
         ScaleWidth      =   24
         TabIndex        =   1
         Top             =   645
         Width           =   390
         Begin PictureBox Picture2
            BackColor       =   &H00000000&
            BorderStyle     =   0  'None
            ForeColor       =   &H00C0C0C0&
            Height          =   165
            Left            =   90
            ScaleHeight     =   11
            ScaleMode       =   3  'Pixel
            ScaleWidth      =   14
            TabIndex        =   6
            Top             =   75
            Width           =   210
         End
      End
      Begin Label lblMonth
         BorderStyle     =   1  'Fixed Single
         Caption         =   "Label1"
         Height          =   165
         Left            =   180
         TabIndex        =   4
         Top             =   330
         Width           =   630
      End
      Begin Label lblYear
         BorderStyle     =   1  'Fixed Single
         Caption         =   "Label1"
         Height          =   210
         Left            =   225
         TabIndex        =   3
         Top             =   120
         Width           =   870
      End
   End
   Begin Label Label1
      BackColor       =   &H00C0C0C0&
      Caption         =   "Click button to display calendar.  Clicking on a date highlights and sets it. A set date can be removed by double clicking on it.  Feel free to improve upon.  Any suggestions to speed display when you advance or retard the calendar with the arrows would be appreciated. This just shows what's possible with VB, alone.  Much was suggested by  VB Knowledge Base article,  ""How to Make a Spreadsheet-style Grid that Allows Editing"". I do contract programming in VB and Access and would appreciate any leads for work you can pass my way.                                        Glenn Silverman :  CompuServe 71450,2750"
      Height          =   2820
      Left            =   225
      TabIndex        =   8
      Top             =   825
      Width           =   3945
   End
'Max grid size
Const grid_col_max = 10
Const grid_row_max = 20
'grid dimensions
Dim w As Single
Dim h As Single
'Current grid size
Dim grid_cols As Integer
Dim grid_rows As Integer
'Current cell position
Dim grid_col As Integer
Dim grid_row As Integer
'Grid string contents
Dim grid_text(35) As String
'Grid cell numbers
Dim cell(35) As Rect
'Grid line positions
Dim grid_line_col(grid_col_max) As Integer
Dim grid_line_row(grid_row_max) As Integer
'Calendar date setting
Dim calDate As Long
Sub AdvanceMonth ()
    Dim c, m, y, ds
    c = DateValue(lblMonth + " 1, " + lblYear)
    m = Month(c) + 1
    If m = 13 Then
        m = 1
        y = Year(c) + 1
    Else
        y = Year(c)
    End If
    ds = DateSerial(y, m, 1)
    ShowMonth ds
End Sub
Sub AdvanceYear ()
    Dim c, m, y, ds
    c = DateValue(lblMonth + " 1, " + lblYear)
    y = Year(c) + 1
    m = Month(c)
    ds = DateSerial(y, m, 1)
    ShowMonth ds
End Sub
Sub btnMonth_Click (Index As Integer)
    If Index = 0 Then
        RetardMonth
    Else
        AdvanceMonth
    End If
End Sub
Sub btnYear_Click (Index As Integer)
    If Index = 1 Then
        AdvanceYear
    Else
        RetardYear
    End If
End Sub
Sub BuildCal ()
    Dim i, l, t
    ReDim DaysOfWeek(7) As String
    Dim x1 As Integer
    Dim x2 As Integer
    Dim y1 As Integer
    Dim y2 As Integer
    DaysOfWeek(0) = "S"
    DaysOfWeek(1) = "M"
    DaysOfWeek(2) = "T"
    DaysOfWeek(3) = "W"
    DaysOfWeek(4) = "T"
    DaysOfWeek(5) = "F"
    DaysOfWeek(6) = "S"
    'Set control dimensions
    h = Calendar.Height / 8
    w = Calendar.Width / 7
    'Set headings
    SetControl lblYear, h, 5 * w + 1, " ", &HC0C0C0
    ControlText lblYear, True, &HC0, 2
    lblYear.Move w, 0
    SetControl lblMonth, h, 5 * w + 1, " ", &HC0C0C0
    ControlText lblMonth, True, &HC0, 2
    lblMonth.Move w, h
   'set weekday heads
   For i = 0 To 6
    x1 = i * w + 10
    y1 = 2 * h + 3
    x2 = (i + 1) * w - 1
    y2 = 3 * h - 1
    Calendar.CurrentX = x1 - 6 + (x2 - x1 - Picture1.TextWidth(DaysOfWeek(i))) / 2
    Calendar.CurrentY = y1 + (y2 - y1 - Picture1.TextHeight(DaysOfWeek(i))) / 2
    Calendar.Print DaysOfWeek(i)
   Next i
   'set grdCal
    Picture1.Move 0, 3 * h, 7 * w, 5 * h
    Picture2.Visible = False
   'build cal grid
    grid_build 7, 5
   'Set buttons
    btnYear(0).Move 0, 0, w, h
    btnYear(0).Caption = "<"
    Load btnYear(1)
    btnYear(1).Visible = True
    btnYear(1).Move 6 * w, 0
    btnYear(1).Caption = ">"
    btnMonth(0).Move 0, h, w, h
    btnMonth(0).Caption = "<"
    Load btnMonth(1)
    btnMonth(1).Visible = True
    btnMonth(1).Move 6 * w, h
    btnMonth(1).Caption = ">"
End Sub
Sub Command1_Click ()
    Calendar.Visible = True
End Sub
Sub ControlText (c As Control, wt, tcol, al)
    c.FontBold = wt
    c.ForeColor = tcol
    c.Alignment = al
End Sub
Function date_set (col As Integer, row As Integer) As Long
    date_set = DateValue(lblMonth + " " + grid_text(row * 7 + col) + ", " + lblYear)
End Function
Sub DayCalc (first, days)
    Dim d, nday
    Dim i As Integer
    Dim c As Rect
    Dim x1 As Integer
    Dim x2 As Integer
    Dim y1 As Integer
    Dim y2 As Integer
    Dim txtColor As Long
    Dim col As Integer
    Dim row As Integer
    For i = 0 To 33 + first
       c = cell(i Mod 35)
       x1 = c.upper.x
       y1 = c.upper.y
       x2 = c.lower.x
       y2 = c.lower.y

       'clear cell
       Picture1.Line (x1 + 1, y1 + 1)-(x2 - 1, y2 - 1), Picture1.BackColor, BF

       d = i - first + 2
       If d < 1 Or d > days Then
          nday = " "
       Else
          nday = d
       End If
       'display day number in cell
        Picture1.CurrentX = x1 - 6 + (x2 - x1 - Picture1.TextWidth(nday)) / 2
        Picture1.CurrentY = y1 + (y2 - y1 - Picture1.TextHeight(nday)) / 2

        If nday = Day(Date) And lblMonth = Format(Date, "mmmm") And lblYear = Format(Date, "yyyy") Then
            txtColor = Picture1.ForeColor
            Picture1.ForeColor = RGB(255, 0, 0)
            Picture1.Print nday
            Picture1.ForeColor = txtColor
        Else
            Picture1.Print nday
        End If
       'store day in grid_text array
        grid_text(i Mod 35) = nday
   Next i
   'calendar date setting
   If lblMonth = Format(calDate, "mmmm") And lblYear = Format(calDate, "yyyy") Then
        c = cell(Day(calDate) - first + 2)
        set_date c.upper.x + 1, c.upper.y + 1
   Else
        Picture2.Visible = False
   End If
End Sub
Sub draw_grid_lines ()
    For i = 0 To grid_cols
        x2% = grid_line_col(i)
        y2% = grid_line_row(grid_rows)
        Picture1.Line (grid_line_col(i), 0)-(x2%, y2%), &H808080
    Next
    For i = 0 To grid_rows
        x2% = grid_line_col(grid_cols)
        y2% = grid_line_row(i)
        Picture1.Line (0, grid_line_row(i))-(x2%, y2%), &H808080
    Next
End Sub
Sub fill_cell_array ()
    Dim col As Integer
    Dim row As Integer
    Dim p1 As Pt
    Dim p2 As Pt
    Dim rt As Rect
    For row = 0 To 4
        For col = 0 To 6
            p1.x = grid_line_col(col) + 1
            p1.y = grid_line_row(row) + 1
            p2.x = grid_line_col(col + 1) - 1
            p2.y = grid_line_row(row + 1) - 1
            rt.upper = p1
            rt.lower = p2
            cell(row * 7 + col) = rt
        Next
    Next
End Sub
Sub Form_Load ()
    BuildCal
    ShowMonth Date
End Sub
Sub grid_build (Cols As Integer, Rows As Integer)
    'set grid size
    grid_cols = Cols
    grid_rows = Rows
    'remove borders
    Picture1.BorderStyle = 0
    'set col widths and row heights
    Dim i As Integer
    Dim d As Integer
    d = 0
    For i = 0 To UBound(grid_line_col)
        grid_line_col(i) = d
        d = d + w
    Next
    d = 0
    For i = 0 To UBound(grid_line_row)
        grid_line_row(i) = d
        d = d + h
    Next
    draw_grid_lines
   'fill cell array
    Call fill_cell_array
    'create grid shadows
    shadow_grid
End Sub
Sub grid_cell_move (col As Integer, row As Integer)
    Dim x1 As Integer
    Dim x2 As Integer
    Dim y1 As Single
    Dim y2 As Single
    Dim nday
    'set new grid current cell
    grid_col = col
    grid_row = row
    'Move label box to new cell
     x1 = grid_line_col(grid_col)
     y1 = grid_line_row(grid_row)
     x2 = grid_line_col(grid_col + 1) - x1
     y2 = grid_line_row(grid_row + 1) - y1
     Picture2.Move x1 + 1, y1 + 1, x2 - 2, y2 - 2
     Picture2.Visible = True
    'Copy contents of new cell to label
     Picture2.Cls
     nday = grid_text(row * 7 + col)
     Picture2.CurrentX = -3 + (x2 - Picture1.TextWidth(nday)) / 2
     Picture2.CurrentY = -.75 + (y2 - Picture1.TextHeight(nday)) / 2
     Picture2.Print nday
End Sub
Sub Picture1_MouseDown (Button As Integer, Shift As Integer, x As Single, y As Single)
    set_date x, y
End Sub
Sub Picture2_DblClick ()
    Picture2.Visible = False
    calDate = 0
End Sub
Sub RetardMonth ()
    Dim c, m, y, ds
    c = DateValue(lblMonth + " 1, " + lblYear)
    m = Month(c) - 1
    If m = 0 Then
        m = 12
        y = Year(c) - 1
    Else
        y = Year(c)
    End If
    ds = DateSerial(y, m, Day(Date))
    ShowMonth ds
End Sub
Sub RetardYear ()
    Dim c, m, y, ds
    c = DateValue(lblMonth + " 1, " + lblYear)
    y = Year(c) - 1
    m = Month(c)
    ds = DateSerial(y, m, 1)
    ShowMonth ds
End Sub
Sub set_date (x As Single, y As Single)
    Dim col As Integer
    Dim row As Integer
    'Find cell clicked in
    col = grid_col
    row = grid_row
    For i = 0 To grid_cols - 1
        If x >= grid_line_col(i) And x < grid_line_col(i + 1) Then
            col = i
            Exit For
        End If
    Next
    For i = 0 To grid_rows - 1
        If y >= grid_line_row(i) And y < grid_line_row(i + 1) Then
            row = i
            Exit For
        End If
    Next
    If grid_text(row * 7 + col) <> " " Then
        Call grid_cell_move(col, row)

        'set the new date
        calDate = date_set(col, row)
    End If
End Sub
Sub SetControl (c As Control, ht, wd, cpt, bkCol)
    c.Height = ht
    c.Width = wd
    c.Caption = cpt
    c.BackColor = bkCol
End Sub
Sub shadow_grid ()
    Dim c As Rect
    Dim i As Integer
    Dim x1 As Integer
    Dim x2 As Integer
    Dim y1 As Integer
    Dim y2 As Integer
    For i = 0 To 34
       c = cell(i)
       x1 = c.upper.x
       y1 = c.upper.y
       x2 = c.lower.x
       y2 = c.lower.y

       Picture1.Line (x1, y2)-(x2, y2), RGB(255, 255, 255)
       Picture1.Line (x2, y1)-(x2, y2), RGB(255, 255, 255)
    Next
End Sub
Sub ShowMonth (dt)
    Dim date1, date2, days, first, currIndex
    lblYear = Format(dt, "yyyy")
    lblMonth = Format(dt, "mmmm")
    date1 = DateSerial(Year(dt), Month(dt), 1)
    date2 = DateAdd("m", 1, date1)
    days = DateDiff("d", date1, date2)
    first = Weekday(date1)
    DayCalc first, days
End Sub